home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / paren.el < prev    next >
Encoding:
Text File  |  1995-08-22  |  12.6 KB  |  366 lines
  1. ;;; paren.el --- highlight (un)matching parens and whole expressions
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1993, 1994, 1995 Tinker Systems
  5. ;;
  6. ;; Author: Jonathan Stigelman <Stig@hackvan.com>
  7. ;; Note:   (some code scammed from simple.el and blink-paren.el)
  8. ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
  9. ;; Keywords: languages, faces
  10.  
  11. ;;; This file is part of XEmacs.
  12. ;;; 
  13. ;;; XEmacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2 of the License, or
  16. ;;; (at your option) any later version.
  17. ;;; 
  18. ;;; XEmacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;; 
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with XEmacs; if not, write to the Free Software
  25. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; Purpose of this package:
  30. ;;
  31. ;;   This package highlights matching parens (or whole sexps) for easier
  32. ;;   editing of source code, particularly lisp source code.
  33. ;; 
  34. ;; The `paren-highlight' hook function runs after each command and
  35. ;; checks to see if the cursor is at a parenthesis.  If so, then it
  36. ;; highlights, in one of several ways, the matching parenthesis.
  37. ;; 
  38. ;; Priority is given to matching parentheses right before the cursor because
  39. ;; that's what makes sense when you're typing a lot of closed parentheses.
  40. ;; 
  41. ;; This is especially intuitive if you frequently use forward-sexp (M-C-f)
  42. ;; and backward-sexp (M-C-b) to maneuver around in source code.
  43. ;; 
  44. ;; Different faces are used for matching and mismatching parens so that it
  45. ;; is easier to see mistakes as you type them.  Audible feedback is optional.
  46. ;; 
  47. ;; If a (mis)matching paren is offscreen, then a message is sent to the modeline.
  48. ;; 
  49. ;; If paren-mode is `sexp', entire S-expressions are highlighted instead of
  50. ;; just matching parens.
  51.  
  52. ;;; Code:
  53.  
  54. (defvar paren-message-offscreen t
  55.   "*Display message if matching open paren is offscreen.")
  56.  
  57. (defvar paren-ding-unmatched nil
  58.   "*Make noise if the cursor is at an unmatched paren.
  59.  
  60. If T, then typing or passing over an unmatched paren will ring the bell
  61. using the `paren' sound.  If NIL, then the bell will not ring even if an
  62. unmatched paren is typed.  If neither T or NIL, then the bell will not ring
  63. when the cursor moves over unmatched parens but will ring if one is typed.")
  64.  
  65. ;;;###autoload
  66. (defvar paren-mode nil
  67.   "*Sets the style of parenthesis highlighting.
  68. Valid values are `blink-paren', `paren', and `sexp'.
  69.   blink-paren    causes the matching paren to blink.
  70.   paren        causes the matching paren to be highlighted but not to blink.
  71.   sexp        whole expression enclosed by the local paren at its mate.
  72.   nested    (not released yet) use variable shading to see the
  73.         nesting of an expression.  Also groks regular expressions
  74.         and shell quoting.
  75.  
  76. This variable is global by default, but you can make it buffer-local and
  77. highlight parentheses differrently in different major modes.")
  78.  
  79. (make-face 'paren-match)
  80. (or (face-differs-from-default-p 'paren-match)
  81.     (copy-face 'highlight 'paren-match))
  82.  
  83. (make-face 'paren-mismatch)
  84. (cond ((face-differs-from-default-p 'paren-mismatch) nil)
  85.       (t (let ((color-tag (list 'x 'color))
  86.            (mono-tag (list 'x 'mono))
  87.            (gray-tag (list 'x 'grayscale)))
  88.        (set-face-background 'paren-mismatch "DeepPink" 'global color-tag)
  89.        (set-face-reverse-p 'paren-mismatch t 'global 'tty)
  90.        (set-face-background 'paren-mismatch [modeline background] 'global
  91.                 mono-tag)
  92.        (set-face-foreground 'paren-mismatch [modeline foreground] 'global
  93.                 mono-tag)
  94.        (set-face-background 'paren-mismatch [modeline background] 'global
  95.                 gray-tag)
  96.        (set-face-foreground 'paren-mismatch [modeline foreground] 'global
  97.                 gray-tag))))
  98.  
  99. (make-face 'paren-blink-off)
  100. (or (face-differs-from-default-p 'paren-blink-off)
  101.     (set-face-foreground 'paren-blink-off (face-background 'default)))
  102.  
  103. ;; this is either paren-match or paren-mismatch...
  104. (defvar paren-blink-on-face nil)
  105.  
  106. (defvar paren-blink-interval 0.2
  107.   "*If the cursor is on a parenthesis, the matching parenthesis will blink.
  108. This variable controls how long each phase of the blink lasts in seconds.
  109. This should be a fractional part of a second (a float.)")
  110.  
  111. (defvar paren-max-blinks (* 5 60 5)    ; 5 minutes is plenty...
  112.   ;; idea from Eric Eide <eeide@jaguar.cs.utah.edu>
  113.   "*Maximum number of times that a matching parenthesis will blink.
  114. Set this to NIL if you want indefinite blinking.")
  115.  
  116. ;; timeout to blink the face
  117. (defvar paren-timeout-id nil)
  118.  
  119. ;; Code:
  120.  
  121. (defvar paren-n-blinks)
  122. (defvar paren-extent nil)
  123.  
  124. ;; used to suppress messages from the same position so that other messages
  125. ;; can be seen in the modeline.
  126. (make-variable-buffer-local
  127.  (defvar paren-message-suppress nil))
  128.  
  129. (defsubst pos-visible-in-window-safe (pos)
  130.   "safe version of pos-visible-in-window-p"
  131.   (condition-case nil
  132.       ;; #### - is this needed in XEmacs???
  133.       (pos-visible-in-window-p pos)
  134.       (args-out-of-range nil)))
  135.  
  136. ;; called before a new command is executed in the pre-command-hook
  137. ;; cleanup by removing the extent and the time-out
  138. (defun paren-nuke-extent ()
  139.   (condition-case c  ; don't ever signal an error in pre-command-hook!
  140.       (let ((inhibit-quit t))
  141.     (if paren-timeout-id
  142.         (disable-timeout (prog1 paren-timeout-id
  143.                    (setq paren-timeout-id nil))))
  144.     (if paren-extent
  145.         (delete-extent (prog1 paren-extent
  146.                  (setq paren-extent nil)))))
  147.     (error
  148.      (message "paren-nuke-extent error! %s" c))))
  149.  
  150. ;; callback for the timeout
  151. ;; swap the face of the extent on the matching paren
  152. (defun paren-blink-timeout (arg)
  153.   ;; The extent could have been deleted for some reason and not point to a
  154.   ;; buffer anymore.  So catch any error to remove the timeout.
  155.   (condition-case ()
  156.       (if (and paren-max-blinks
  157.            (> (setq paren-n-blinks (1+ paren-n-blinks)) paren-max-blinks))
  158.       (paren-nuke-extent)
  159.     (set-extent-face paren-extent 
  160.              (if (eq (extent-face paren-extent)
  161.                  paren-blink-on-face)
  162.                  'paren-blink-off
  163.                paren-blink-on-face)))
  164.     (error (paren-nuke-extent))))
  165.  
  166.  
  167. (defun paren-describe-match (pos mismatch)  
  168.   (or (window-minibuffer-p (selected-window))
  169.       (save-excursion
  170.     (goto-char pos)
  171.     (message "%s %s"
  172.          (if mismatch "MISMATCH:" "Matches")
  173.          ;; if there's stuff on this line preceding the paren, then
  174.          ;; display text from beginning of line to paren.
  175.          ;;
  176.          ;; If, however, the paren is at the beginning of a line, then
  177.          ;; skip whitespace forward and display text from paren to end
  178.          ;; of the next line containing nonspace text.
  179.          ;;
  180.          ;; If paren-backwards-message gravity were implemented, then
  181.          ;; perhaps it would reverse this behavior and look to the
  182.          ;; previous line for meaningful context.
  183.          (if (save-excursion
  184.                (skip-chars-backward " \t")
  185.                (not (bolp)))
  186.              (concat (buffer-substring
  187.                   (progn (beginning-of-line) (point))
  188.                   (1+ pos)) "...")
  189.            (buffer-substring
  190.             pos (progn
  191.               (forward-char 1)
  192.               (skip-chars-forward "\n \t")
  193.               (end-of-line)
  194.               (point))))))))
  195.  
  196. (defun paren-maybe-ding ()
  197.   (and (or (eq paren-ding-unmatched t)
  198.        (and paren-ding-unmatched
  199.         (eq this-command 'self-insert-command)))
  200.        (progn
  201.      (message "Unmatched parenthesis.")
  202.      (ding nil 'paren))))
  203.  
  204. ;; Find the place to show, if there is one,
  205. ;; and show it until input arrives.
  206. (defun paren-highlight ()
  207.   "This highlights matching parentheses.
  208.  
  209. See the variables:
  210.   paren-message-offscreen   use modeline when matchingparen is offscreen?
  211.   paren-ding-unmatched        make noise when passing over mismatched parens?
  212.   paren-mode            'blink-paren, 'paren, or 'sexp
  213.   blink-matching-paren-distance  maximum distance to search for parens.
  214.  
  215. and the following faces:
  216.   paren-match, paren-mismatch, paren-blink-off"
  217.  
  218.   ;; I suppose I could check here to see if a keyboard macro is executing,
  219.   ;; but I did a quick empirical check and couldn't tell that there was any
  220.   ;; difference in performance
  221.  
  222.   (let ((oldpos (point))
  223.     (pface nil)            ; face for paren...nil kills the overlay
  224.     (dir (and paren-mode
  225.           (not (input-pending-p))
  226.           (not executing-kbd-macro)
  227.           (cond ((eq (char-syntax (preceding-char)) ?\))
  228.              -1)
  229.             ((eq (char-syntax (following-char)) ?\()
  230.              1))))
  231.     pos mismatch)
  232.  
  233.     (save-excursion
  234.       (if (or (not dir)
  235.           (not (save-restriction
  236.              ;; Determine the range within which to look for a match.
  237.              (if blink-matching-paren-distance
  238.              (narrow-to-region
  239.               (max (point-min)
  240.                    (- (point) blink-matching-paren-distance))
  241.               (min (point-max)
  242.                    (+ (point) blink-matching-paren-distance))))
  243.  
  244.              ;; Scan across one sexp within that range.
  245.              (condition-case nil
  246.              (setq pos (scan-sexps (point) dir))
  247.                ;; NOTE - if blink-matching-paren-distance is set,
  248.                ;; then we can have spurious unmatched parens.
  249.                (error (paren-maybe-ding)
  250.                   nil)))))
  251.  
  252.       ;; do nothing if we didn't find a matching paren...
  253.       nil
  254.  
  255.     ;; See if the "matching" paren is the right kind of paren
  256.     ;; to match the one we started at.
  257.     (let ((beg (min pos oldpos)) (end (max pos oldpos)))
  258.       (setq mismatch
  259.         (and (/= (char-syntax (char-after beg)) ?\\)
  260.              (/= (char-syntax (char-after beg)) ?\$)
  261.              (/= (char-after (1- end))
  262.              (logand (lsh (aref (syntax-table)
  263.                         (char-after beg))
  264.                       -8)
  265.                  255))))
  266.       (if (eq paren-mode 'sexp)
  267.           (setq paren-extent (make-extent beg end))))
  268.     (and mismatch
  269.          (paren-maybe-ding))
  270.      (setq pface (if mismatch
  271.             'paren-mismatch
  272.               'paren-match))
  273.     (and (memq paren-mode '(blink-paren paren))
  274.          (setq paren-extent (make-extent (- pos dir) pos)))
  275.  
  276.     (if (and paren-message-offscreen
  277.          (eq dir -1)
  278.          (not (eq paren-message-suppress (point)))
  279.          (not (window-minibuffer-p (selected-window)))
  280.          (not (pos-visible-in-window-safe pos)))
  281.         (progn
  282.           (setq paren-message-suppress (point))
  283.           (paren-describe-match pos mismatch))
  284.       (setq paren-message-suppress nil))
  285.          
  286.     ;; put the right face on the extent
  287.     (cond (pface
  288.            (set-extent-face paren-extent pface) 
  289.            (set-extent-priority paren-extent 100) ; want this to be high
  290.            (and (eq paren-mode 'blink-paren)
  291.             (setq paren-blink-on-face pface
  292.               paren-n-blinks 0
  293.               paren-timeout-id
  294.               (and paren-blink-interval
  295.                    (add-timeout paren-blink-interval
  296.                         'paren-blink-timeout
  297.                         nil
  298.                         paren-blink-interval))))))
  299.     ))))
  300.  
  301. ;; kill off the competition, er, uh, eliminate redundancy...
  302. (setq post-command-hook (delq 'show-paren-command-hook post-command-hook))
  303. (setq pre-command-hook (delq 'blink-paren-pre-command pre-command-hook))
  304. (setq post-command-hook (delq 'blink-paren-post-command post-command-hook))
  305.  
  306. ;;;###autoload
  307. (defun paren-set-mode (arg &optional quiet)
  308.   "Cycles through possible values for `paren-mode', force off with negative arg.
  309. When called from lisp, a symbolic value for `paren-mode' can be pased directly.
  310. See also `paren-mode' and `paren-highlight'."
  311.   (interactive "P")
  312.   (let* ((paren-modes '(blink-paren paren sexp))
  313.      (paren-next-modes (cons nil (append paren-modes (list nil)))))
  314.     (setq paren-mode (if (and (numberp arg) (< arg 0))
  315.              nil        ; turn paren highlighting off
  316.                (cond ((and arg (symbolp arg)) arg)
  317.                  ((and (numberp arg) (> arg 0))
  318.                   (nth (1- arg) paren-modes))
  319.                  ((numberp arg) nil)
  320.                  (t (car (cdr (memq paren-mode
  321.                         paren-next-modes)))))
  322.                )))
  323.   (cond (paren-mode
  324.      (add-hook 'post-command-hook 'paren-highlight)
  325.      (add-hook 'pre-command-hook 'paren-nuke-extent)
  326.      (setq blink-matching-paren nil))
  327.     ((not (local-variable-p 'paren-mode (current-buffer)))
  328.      (remove-hook 'post-command-hook 'paren-highlight)
  329.      (remove-hook 'pre-command-hook 'paren-nuke-extent)
  330.      (paren-nuke-extent)        ; overkill
  331.      (setq blink-matching-paren t)
  332.      ))
  333.   (or quiet (message "Paren mode is %s" (or paren-mode "OFF"))))
  334.  
  335. (eval-when-compile
  336.   ;; suppress compiler warning.
  337.   (defvar highlight-paren-expression))
  338.  
  339. (paren-set-mode (if (and (boundp 'highlight-paren-expression)
  340.                 ;; bletcherous blink-paren no-naming-convention
  341.                 highlight-paren-expression)
  342.                'sexp
  343.              (if (eq 'x (device-type (selected-device)))
  344.              'blink-paren
  345.                'paren))
  346.         t)
  347.  
  348. ;;;###autoload
  349. (make-obsolete 'blink-paren 'paren-set-mode)
  350.  
  351. ;;;###autoload
  352. (defun blink-paren (&optional arg)
  353.   "Obsolete.  Use `paren-set-mode' instead."
  354.   (interactive "P") 
  355.   (paren-set-mode (if (and (numberp arg) (> arg 0))
  356.               'blink-paren -1) t))
  357.  
  358. (provide 'blink-paren)
  359. (provide 'paren)
  360.  
  361. ;; Local Variables:
  362. ;; byte-optimize: t
  363. ;; End:
  364.  
  365. ;;; paren.el ends here
  366.